home *** CD-ROM | disk | FTP | other *** search
/ Freelog 15 / FREELOG 15.ISO / WebMaster / Perl / PERL5106.ZIP / perl5 / Lib / ExtUtils / xsubpp < prev   
Encoding:
Text File  |  1995-12-02  |  23.6 KB  |  957 lines
  1. #!./miniperl
  2.  
  3. =head1 NAME
  4.  
  5. xsubpp - compiler to convert Perl XS code into C code
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>]... file.xs
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. I<xsubpp> will compile XS code into C code by embedding the constructs
  14. necessary to let C functions manipulate Perl values and creates the glue
  15. necessary to let Perl access those functions.  The compiler uses typemaps to
  16. determine how to map C function parameters and variables to Perl values.
  17.  
  18. The compiler will search for typemap files called I<typemap>.  It will use
  19. the following search path to find default typemaps, with the rightmost
  20. typemap taking precedence.
  21.  
  22.     ../../../typemap:../../typemap:../typemap:typemap
  23.  
  24. =head1 OPTIONS
  25.  
  26. =over 5
  27.  
  28. =item B<-C++>
  29.  
  30. Adds ``extern "C"'' to the C code.
  31.  
  32.  
  33. =item B<-except>
  34.  
  35. Adds exception handling stubs to the C code.
  36.  
  37. =item B<-typemap typemap>
  38.  
  39. Indicates that a user-supplied typemap should take precedence over the
  40. default typemaps.  This option may be used multiple times, with the last
  41. typemap having the highest precedence.
  42.  
  43. =back
  44.  
  45. =head1 ENVIRONMENT
  46.  
  47. No environment variables are used.
  48.  
  49. =head1 AUTHOR
  50.  
  51. Larry Wall
  52.  
  53. =head1 MODIFICATION HISTORY
  54.  
  55. =head2 1.0
  56.  
  57. I<xsubpp> as released with Perl 5.000
  58.  
  59. =head2 1.1
  60.  
  61. I<xsubpp> as released with Perl 5.001
  62.  
  63. =head2 1.2 
  64.  
  65. Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.
  66.  
  67. =over 5
  68.  
  69. =item 1.
  70.  
  71. Added I<xsubpp> version number for the first time. As previous releases
  72. of I<xsubpp> did not have a formal version number, a numbering scheme
  73. has been applied retrospectively.
  74.  
  75. =item 2.
  76.  
  77. If OUTPUT: is being used to specify output parameters and RETVAL is
  78. also to be returned, it is now no longer necessary for the user to
  79. ensure that RETVAL is specified last.
  80.  
  81. =item 3.
  82.  
  83. The I<xsubpp> version number, the .xs filename and a time stamp are
  84. written to the generated .c file as a comment.
  85.  
  86. =item 4.
  87.  
  88. When I<xsubpp> is parsing the definition of both the input parameters
  89. and the OUTPUT parameters, any duplicate definitions will be noted and
  90. ignored.
  91.  
  92. =item 5.
  93.  
  94. I<xsubpp> is slightly more forgiving with extra whitespace.
  95.  
  96. =back
  97.  
  98. =head2 1.3 
  99.  
  100. Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.
  101.  
  102. =over 5
  103.  
  104. =item 1.
  105.  
  106. More whitespace restrictions have been relaxed. In particular some
  107. cases where a tab character was used to delimit fields has been
  108. removed. In these cases any whitespace will now suffice.
  109.  
  110. The specific places where changes have been made are in the TYPEMAP
  111. section of a typemap file and the input and OUTPUT: parameter
  112. declarations sections in a .xs file.
  113.  
  114. =item 2.
  115.  
  116. More error checking added.
  117.  
  118. Before processing each typemap file I<xsubpp> now checks that it is a
  119. text file. If not an warning will be displayed. In addition, a warning
  120. will be displayed if it is not possible to open the typemap file.
  121.  
  122. In the TYPEMAP section of a typemap file, an error will be raised if
  123. the line does not have 2 columns.
  124.  
  125. When parsing input parameter declarations check that there is at least
  126. a type and name pair.
  127.  
  128. =back
  129.  
  130. =head2 1.4 
  131.  
  132. When parsing the OUTPUT arguments check that they are all present in
  133. the corresponding input argument definitions.
  134.  
  135. =head2 1.5 
  136.  
  137. Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 1 June 1995.
  138.  
  139. Started tidy up to allow clean run using C<-w> flag. 
  140.  
  141. Added some more error checking.
  142.  
  143. The CASE: functionality now works.
  144.  
  145. =head2 1.6 
  146.  
  147. Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 3 June 1995.
  148.  
  149. Added some more error checking.
  150.  
  151. =head2 1.7 
  152.  
  153. Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 5 June 1995.
  154.  
  155. When an error or warning message is printed C<xsubpp> will now attempt
  156. to identify the exact line in the C<.xs> file where the fault occurs.
  157. This can be achieved in the majority of cases.
  158.  
  159. =head2 1.8 
  160.  
  161. Changes by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>, 6 June 1995.
  162.  
  163. Accept backslash-newline as in C.  Allow preprocessor directives
  164. anywhere.  Ignore whitespace in front of comments and on blank lines.
  165.  
  166. =head2 1.9 
  167.  
  168. Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 21 June 1995.
  169.  
  170. =over 5
  171.  
  172. =item 1.
  173.  
  174. Changed duplicate function error to a warning.
  175.  
  176. =item 2.
  177.  
  178. Changed the comment placed at the top of the C<.c> file to be more like
  179. the comment used by MakeMaker.
  180.  
  181. =item 3.
  182.  
  183. When parsing the type for an XSUB parameter I<xsubpp> can now accept
  184. definitions like this:
  185.  
  186.     char *fred
  187.  
  188. i.e. the '*' is recognised as part of the type, rather than the first
  189. character of the variable.
  190.  
  191. =item 4.
  192.  
  193. Fixed a problem with command line parsing - I<xsubpp> was not properly
  194. detecting the case where there was no filename present on the command
  195. line.
  196.  
  197. =back
  198.  
  199. =head1 SEE ALSO
  200.  
  201. perl(1), perlapi(1)
  202.  
  203. =cut
  204.  
  205. use Cwd;
  206.  
  207. # Global Constants
  208. $XSUBPP_version = "1.9" ;
  209.  
  210. $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
  211.  
  212. SWITCH: while ($ARGV[0] =~ /^-/) {
  213.     $flag = shift @ARGV;
  214.     $flag =~ s/^-// ;
  215.     $spat = shift,    next SWITCH    if $flag eq 's';
  216.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  217.     $except = 1,    next SWITCH    if $flag eq 'except';
  218.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  219.     die $usage;
  220. }
  221. @ARGV == 1 or die $usage;
  222. chomp($pwd = cwd);
  223. # Check for error message from VMS
  224. if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
  225. ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
  226.     or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
  227.     or ($dir, $filename) = ('.', $ARGV[0]);
  228. chdir($dir);
  229.  
  230. sub TrimWhitespace
  231. {
  232.     $_[0] =~ s/^\s+|\s+$//go ;
  233. }
  234.  
  235. sub TidyType
  236. {
  237.     local ($_) = @_ ;
  238.  
  239.     # rationalise any '*' by joining them into bunches and removing whitespace
  240.     s#\s*(\*+)\s*#$1#g;
  241.     s#(\*+)# $1 #g ;
  242.  
  243.     # change multiple whitespace into a single space
  244.     s/\s+/ /g ;
  245.     
  246.     # trim leading & trailing whitespace
  247.     TrimWhitespace($_) ;
  248.  
  249.     $_ ;
  250. }
  251.  
  252. $typemap = shift @ARGV;
  253. foreach $typemap (@tm) {
  254.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  255. }
  256. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  257.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  258.                 ../typemap typemap);
  259. foreach $typemap (@tm) {
  260.     next unless -e $typemap ;
  261.     # skip directories, binary files etc.
  262.     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
  263.     unless -T $typemap ;
  264.     open(TYPEMAP, $typemap) 
  265.     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
  266.     $mode = 'Typemap';
  267.     $junk = "" ;
  268.     $current = \$junk;
  269.     while (<TYPEMAP>) {
  270.     next if /^\s*#/;
  271.     if (/^INPUT\s*$/)   { $mode = 'Input';   next; }
  272.     if (/^OUTPUT\s*$/)  { $mode = 'Output';  next; }
  273.     if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
  274.     if ($mode eq 'Typemap') {
  275.         chomp;
  276.         my $line = $_ ;
  277.             TrimWhitespace($_) ;
  278.         # skip blank lines and comment lines
  279.         next if /^$/ or /^#/ ;
  280.         my @words = split (' ') ;
  281.         warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next 
  282.         unless @words >= 2 ;
  283.         my $kind = pop @words ;
  284.             TrimWhitespace($kind) ;
  285.         $type_kind{TidyType("@words")} = $kind ;
  286.     }
  287.     elsif ($mode eq 'Input') {
  288.         if (/^\s/) {
  289.         $$current .= $_;
  290.         }
  291.         else {
  292.         s/\s*$//;
  293.         $input_expr{$_} = '';
  294.         $current = \$input_expr{$_};
  295.         }
  296.     }
  297.     else {
  298.         if (/^\s/) {
  299.         $$current .= $_;
  300.         }
  301.         else {
  302.         s/\s*$//;
  303.         $output_expr{$_} = '';
  304.         $current = \$output_expr{$_};
  305.         }
  306.     }
  307.     }
  308.     close(TYPEMAP);
  309. }
  310.  
  311. foreach $key (keys %input_expr) {
  312.     $input_expr{$key} =~ s/\n+$//;
  313. }
  314.  
  315. sub Q {
  316.     my($text) = @_;
  317.     $text =~ tr/#//d;
  318.     $text =~ s/\[\[/{/g;
  319.     $text =~ s/\]\]/}/g;
  320.     $text;
  321. }
  322.  
  323. open(F, $filename) or die "cannot open $filename: $!\n";
  324.  
  325. # Identify the version of xsubpp used
  326. print <<EOM ;
  327. /*
  328.  * This file was generated automatically by xsubpp version $XSUBPP_version from the 
  329.  * contents of $filename. Don't edit this file, edit $filename instead.
  330.  *
  331.  *    ANY CHANGES MADE HERE WILL BE LOST! 
  332.  *
  333.  */
  334.  
  335. EOM
  336.  
  337.  
  338. while (<F>) {
  339.     last if ($Module, $Package, $Prefix) =
  340.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
  341.     print $_;
  342. }
  343. &Exit unless defined $_;
  344.  
  345. my $lastline    = $_;
  346. my $lastline_no = $.;
  347.  
  348.  
  349. # Read next xsub into @line from ($lastline, <F>).
  350. sub fetch_para {
  351.     # parse paragraph
  352.     @line = ();
  353.     @line_no = () ;
  354.     return 0 unless defined $lastline;
  355.  
  356.     if ($lastline =~
  357.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  358.     $Module = $1;
  359.     $Package = $2;
  360.     $Prefix = $3;
  361.     ($Module_cname = $Module) =~ s/\W/_/g;
  362.     ($Packid = $Package) =~ s/:/_/g;
  363.     $Packprefix = $Package;
  364.     $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
  365.     $lastline = "";
  366.     }
  367.  
  368.     for(;;) {
  369.     if ($lastline !~ /^\s*#/ ||
  370.         $lastline =~ /^#[ \t]*((if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
  371.         last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
  372.         push(@line, $lastline);
  373.         push(@line_no, $lastline_no) ;
  374.     }
  375.  
  376.     # Read next line and continuation lines
  377.     last unless defined($lastline = <F>);
  378.     $lastline_no = $.;
  379.     my $tmp_line;
  380.     $lastline .= $tmp_line
  381.         while ($lastline =~ /\\\n$/ && defined($tmp_line = <F>));
  382.         
  383.     # chomp $lastline;
  384.     $lastline =~ s/^\s+$//;
  385.     }
  386.     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
  387.     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
  388.     1;
  389. }
  390.  
  391. PARAGRAPH:
  392. while (&fetch_para) {
  393.     # Print initial preprocessor statements and blank lines
  394.     print shift(@line), "\n"
  395.     while @line && $line[0] !~ /^[^\#]/;
  396.  
  397.     next PARAGRAPH unless @line;
  398.  
  399.     death ("Code is not inside a function")
  400.     if $line[0] =~ /^\s/;
  401.  
  402.     # initialize info arrays
  403.     # my(%args_match,%var_types,%var_addr);
  404.     # my($class,$static,$elipsis,$wantRETVAL,%arg_list);
  405.     undef(%args_match);
  406.     undef(%var_types);
  407.     undef(%var_addr);
  408.     undef(%defaults);
  409.     undef($class);
  410.     undef($static);
  411.     undef($elipsis);
  412.     undef($wantRETVAL) ;
  413.     undef(%arg_list) ;
  414.  
  415.     # extract return type, function name and arguments
  416.     my($ret_type) = TidyType(shift(@line));
  417.  
  418.     if ($ret_type =~ /^BOOT\s*:/) {
  419.         push (@BootCode, @line, "", "") ;
  420.         next PARAGRAPH ;
  421.     }
  422.  
  423.     # a function definition needs at least 2 lines
  424.     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
  425.     unless @line ;
  426.  
  427.     if ($ret_type =~ /^static\s+(.*)$/) {
  428.         $static = 1;
  429.         $ret_type = $1;
  430.     }
  431.     $func_header = shift(@line);
  432.     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
  433.     unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
  434.  
  435.     ($func_name, $orig_args) =  ($1, $2) ;
  436.     if ($func_name =~ /(.*)::(.*)/) {
  437.         $class = $1;
  438.         $func_name = $2;
  439.     }
  440.     $Prefix = '' unless defined $Prefix ; # keep -w happy
  441.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  442.  
  443.     # Check for duplicate function definition
  444.     Warn("Warning: duplicate function definition '$func_name' detected")
  445.     if defined $Func_name{"${Packid}_$func_name"} ;
  446.     $Func_name{"${Packid}_$func_name"} ++ ;
  447.  
  448.     push(@Func_name, "${Packid}_$func_name");
  449.     push(@Func_pname, $pname);
  450.     @args = split(/\s*,\s*/, $orig_args);
  451.     if (defined($class)) {
  452.     if (defined($static)) {
  453.         unshift(@args, "CLASS");
  454.         $orig_args = "CLASS, $orig_args";
  455.         $orig_args =~ s/^CLASS, $/CLASS/;
  456.     }
  457.     else {
  458.         unshift(@args, "THIS");
  459.         $orig_args = "THIS, $orig_args";
  460.         $orig_args =~ s/^THIS, $/THIS/;
  461.     }
  462.     }
  463.     $orig_args =~ s/"/\\"/g;
  464.     $min_args = $num_args = @args;
  465.     foreach $i (0..$num_args-1) {
  466.         if ($args[$i] =~ s/\.\.\.//) {
  467.             $elipsis = 1;
  468.             $min_args--;
  469.             if ($args[$i] eq '' && $i == $num_args - 1) {
  470.             pop(@args);
  471.             last;
  472.             }
  473.         }
  474.         if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
  475.             $min_args--;
  476.             $args[$i] = $1;
  477.             $defaults{$args[$i]} = $2;
  478.             $defaults{$args[$i]} =~ s/"/\\"/g;
  479.         }
  480.     }
  481.     if (defined($class)) {
  482.         $func_args = join(", ", @args[1..$#args]);
  483.     } else {
  484.         $func_args = join(", ", @args);
  485.     }
  486.     @args_match{@args} = 1..@args;
  487.  
  488.     # print function header
  489.     print Q<<"EOF";
  490. #XS(XS_${Packid}_$func_name)
  491. #[[
  492. #    dXSARGS;
  493. EOF
  494.     if ($elipsis) {
  495.     $cond = qq(items < $min_args);
  496.     }
  497.     elsif ($min_args == $num_args) {
  498.     $cond = qq(items != $min_args);
  499.     }
  500.     else {
  501.     $cond = qq(items < $min_args || items > $num_args);
  502.     }
  503.  
  504.     print Q<<"EOF" if $except;
  505. #    char errbuf[1024];
  506. #    *errbuf = '\0';
  507. EOF
  508.  
  509.     print Q<<"EOF";
  510. #    if ($cond) {
  511. #    croak("Usage: $pname($orig_args)");
  512. #    }
  513. EOF
  514.  
  515.     print Q<<"EOF" if $PPCODE;
  516. #    SP -= items;
  517. EOF
  518.  
  519.     # Now do a block of some sort.
  520.  
  521.     $condnum = 0;
  522.     $else_cond = 0 ;
  523.     if (!@line) {
  524.     @line = "CLEANUP:";
  525.     }
  526.     while (@line) {
  527.     if ($line[0] =~ s/^\s*CASE\s*:\s*//) {
  528.         $cond = shift(@line);
  529.             TrimWhitespace($cond) ;
  530.         if ($condnum == 0) {
  531.         # Check $cond is not blank
  532.         blurt("Error: First CASE: needs a condition") 
  533.             if $cond eq '' ;
  534.         print "    if ($cond)\n"
  535.         }
  536.         elsif ($cond ne '') {
  537.         print "    else if ($cond)\n";
  538.         }
  539.         else {
  540.         blurt ("Error: Too many CASE: statements without a condition")
  541.             unless $else_cond ;
  542.                 ++ $else_cond  ;
  543.         print "    else\n";
  544.         }
  545.         $condnum++;
  546.             $_ = '' ;
  547.     }
  548.  
  549.     if ($except) {
  550.         print Q<<"EOF";
  551. #    TRY [[
  552. EOF
  553.     }
  554.     else {
  555.         print Q<<"EOF";
  556. #    [[
  557. EOF
  558.     }
  559.  
  560.     # do initialization of input variables
  561.     $thisdone = 0;
  562.     $retvaldone = 0;
  563.     $deferred = "";
  564.     %arg_list = () ;
  565.         $gotRETVAL = 0;
  566.     while (@line) {
  567.         $_ = shift(@line);
  568.         last if /^\s*NOT_IMPLEMENTED_YET/;
  569.         last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
  570.  
  571.                 TrimWhitespace($_) ;
  572.                 # skip blank lines 
  573.                 next if /^$/ ;
  574.         my $line = $_ ;
  575.  
  576.                 # remove trailing semicolon if no initialisation
  577.                 s/\s*;+\s*$//g unless /=/ ;
  578.  
  579.           # check for optional initialisation code
  580.         my $var_init = '' ;
  581.         $var_init = $1 if s/\s*(=.*)$// ;
  582.  
  583.                 my @words = split (' ') ;
  584.                 blurt("Error: invalid argument declaration '$line'"), next
  585.                     unless @words >= 2 ;
  586.                 my $var_name = pop @words ;
  587.  
  588.         # move any *'s from the variable name to the type
  589.         push(@words, $1)
  590.             if $var_name =~ s/^(\*+)// ;
  591.  
  592.         # check that removing the *'s hasn't eaten the whole variable
  593.         blurt("Error: invalid argument declaration '$line'"), next
  594.             if $var_name eq '' ;
  595.  
  596.         my $var_type = "@words" ;
  597.  
  598.         # catch many errors similar to: SV<tab>* name
  599.         blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
  600.             unless ($var_name =~ m/^&?\w+$/);
  601.         if ($var_name =~ /^&/) {
  602.             $var_name =~ s/^&//;
  603.             $var_addr{$var_name} = 1;
  604.         }
  605.  
  606.             # Check for duplicate definitions
  607.             blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
  608.             if $arg_list{$var_name} ++  ;
  609.  
  610.         $thisdone |= $var_name eq "THIS";
  611.         $retvaldone |= $var_name eq "RETVAL";
  612.         $var_types{$var_name} = $var_type;
  613.         print "\t" . &map_type($var_type);
  614.         $var_num = $args_match{$var_name};
  615.         if ($var_addr{$var_name}) {
  616.             $func_args =~ s/\b($var_name)\b/&$1/;
  617.         }
  618.         if ($var_init !~ /^=\s*NO_INIT\s*$/) {
  619.             if ($var_init !~ /^\s*$/) {
  620.                 &output_init($var_type, $var_num,
  621.                     "$var_name $var_init");
  622.             } elsif ($var_num) {
  623.                 # generate initialization code
  624.                 &generate_init($var_type, $var_num, $var_name);
  625.             } else {
  626.                 print ";\n";
  627.             }
  628.         } else {
  629.             print "\t$var_name;\n";
  630.         }
  631.     }
  632.     if (!$thisdone && defined($class)) {
  633.         if (defined($static)) {
  634.         print "\tchar *";
  635.         $var_types{"CLASS"} = "char *";
  636.         &generate_init("char *", 1, "CLASS");
  637.         }
  638.         else {
  639.         print "\t$class *";
  640.         $var_types{"THIS"} = "$class *";
  641.         &generate_init("$class *", 1, "THIS");
  642.         }
  643.     }
  644.  
  645.     # do code
  646.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  647.         print "\ncroak(\"$pname: not implemented yet\");\n";
  648.     } else {
  649.         if ($ret_type ne "void") {
  650.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  651.                 if !$retvaldone;
  652.             $args_match{"RETVAL"} = 0;
  653.             $var_types{"RETVAL"} = $ret_type;
  654.         }
  655.         if (/^\s*PPCODE\s*:/) {
  656.             print $deferred;
  657.             while (@line) {
  658.                 $_ = shift(@line);
  659.                 death ("PPCODE must be last thing")
  660.                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  661.                 print "$_\n";
  662.             }
  663.             print "\tPUTBACK;\n\treturn;\n";
  664.         } elsif (/^\s*CODE\s*:/) {
  665.             print $deferred;
  666.             while (@line) {
  667.                 $_ = shift(@line);
  668.                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  669.                 print "$_\n";
  670.             }
  671.         } elsif ($func_name eq "DESTROY") {
  672.             print $deferred;
  673.             print "\n\t";
  674.             print "delete THIS;\n"
  675.         } else {
  676.             print $deferred;
  677.             print "\n\t";
  678.             if ($ret_type ne "void") {
  679.                 print "RETVAL = ";
  680.                 $wantRETVAL = 1;
  681.             }
  682.             if (defined($static)) {
  683.                 if ($func_name =~ /^new/) {
  684.                 $func_name = "$class";
  685.                 }
  686.                 else {
  687.                 print "$class::";
  688.                 }
  689.             } elsif (defined($class)) {
  690.                 print "THIS->";
  691.             }
  692.             $func_name =~ s/^($spat)//
  693.                 if defined($spat);
  694.             print "$func_name($func_args);\n";
  695.         }
  696.     }
  697.  
  698.     # do output variables
  699.     if (/^\s*OUTPUT\s*:/) {
  700.         $gotRETVAL = 0;
  701.         my $RETVAL_code ;
  702.         my %outargs ;
  703.         while (@line) {
  704.             $_ = shift(@line);
  705.             last if /^\s*(CLEANUP|CASE)\s*:/;
  706.             TrimWhitespace($_) ;
  707.             next if /^$/ ;
  708.             my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
  709.             if (!$gotRETVAL and $outarg eq 'RETVAL') {
  710.                 # deal with RETVAL last
  711.                 $RETVAL_code = $outcode ;
  712.                 $gotRETVAL = 1 ;
  713.                 next ;
  714.             }
  715.             blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
  716.                 if $outargs{$outarg} ++ ;
  717.             blurt ("Error: OUTPUT $outarg not an argument"), next
  718.                 unless defined($args_match{$outarg});
  719.             blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
  720.                 unless defined $var_types{$outarg} ;
  721.             if ($outcode) {
  722.                 print "\t$outcode\n";
  723.             } else {
  724.                 $var_num = $args_match{$outarg};
  725.                 &generate_output($var_types{$outarg}, $var_num,
  726.                     $outarg); 
  727.             }
  728.         }
  729.  
  730.         if ($gotRETVAL) {
  731.             if ($RETVAL_code) 
  732.                             { print "\t$RETVAL_code\n" }
  733.             else 
  734.                 { &generate_output($ret_type, 0, 'RETVAL') }
  735.         }
  736.     }
  737.  
  738.     # all OUTPUT done, so now push the return value on the stack
  739.     &generate_output($ret_type, 0, "RETVAL")
  740.          if $wantRETVAL and ! $gotRETVAL ;
  741.  
  742.     # do cleanup
  743.     if (/^\s*CLEANUP\s*:/) {
  744.         while (@line) {
  745.             $_ = shift(@line);
  746.             last if /^\s*CASE\s*:/;
  747.             print "$_\n";
  748.         }
  749.     }
  750.     # print function trailer
  751.     if ($except) {
  752.         print Q<<EOF;
  753. #    ]]
  754. #    BEGHANDLERS
  755. #    CATCHALL
  756. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  757. #    ENDHANDLERS
  758. EOF
  759.     }
  760.     else {
  761.         print Q<<EOF;
  762. #    ]]
  763. EOF
  764.     }
  765.     if (/^\s*CASE\s*:/) {
  766.         unshift(@line, $_);
  767.     }
  768.     }
  769.  
  770.     print Q<<EOF if $except;
  771. #    if (errbuf[0])
  772. #    croak(errbuf);
  773. EOF
  774.  
  775.     print Q<<EOF unless $PPCODE;
  776. #    XSRETURN(1);
  777. EOF
  778.  
  779.     print Q<<EOF;
  780. #]]
  781. #
  782. EOF
  783. }
  784.  
  785. # print initialization routine
  786. print qq/extern "C"\n/ if $cplusplus;
  787. print Q<<"EOF";
  788. #XS(boot_$Module_cname)
  789. #[[
  790. #    dXSARGS;
  791. #    char* file = __FILE__;
  792. #
  793. EOF
  794.  
  795. for (@Func_name) {
  796.     $pname = shift(@Func_pname);
  797.     print "    newXS(\"$pname\", XS_$_, file);\n";
  798. }
  799.  
  800. if (@BootCode)
  801. {
  802.     print "\n    /* Initialisation Section */\n\n" ;
  803.     print grep (s/$/\n/, @BootCode) ;
  804.     print "    /* End of Initialisation Section */\n\n" ;
  805. }
  806.  
  807. print Q<<"EOF";;
  808. #    ST(0) = &sv_yes;
  809. #    XSRETURN(1);
  810. #]]
  811. EOF
  812.  
  813. &Exit;
  814.  
  815.  
  816. sub output_init {
  817.     local($type, $num, $init) = @_;
  818.     local($arg) = "ST(" . ($num - 1) . ")";
  819.  
  820.     eval qq/print " $init\\\n"/;
  821. }
  822.  
  823. sub Warn
  824. {
  825.     # work out the line number
  826.     my $line_no = $line_no[@line_no - @line -1] ;
  827.  
  828.     print STDERR "@_ in $filename, line $line_no\n" ;
  829. }
  830.  
  831. sub blurt 
  832. { 
  833.     Warn @_ ;
  834.     $errors ++ 
  835. }
  836.  
  837. sub death
  838. {
  839.     Warn @_ ;
  840.     exit 1 ;
  841. }
  842.  
  843. sub generate_init {
  844.     local($type, $num, $var) = @_;
  845.     local($arg) = "ST(" . ($num - 1) . ")";
  846.     local($argoff) = $num - 1;
  847.     local($ntype);
  848.     local($tk);
  849.  
  850.     $type = TidyType($type) ;
  851.     blurt("Error: '$type' not in typemap"), return 
  852.     unless defined($type_kind{$type});
  853.  
  854.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  855.     $subtype = $ntype;
  856.     $subtype =~ s/Ptr$//;
  857.     $subtype =~ s/Array$//;
  858.     $tk = $type_kind{$type};
  859.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  860.     $type =~ s/:/_/g;
  861.     blurt("Error: No INPUT definition for type '$type' found"), return
  862.         unless defined $input_expr{$tk} ;
  863.     $expr = $input_expr{$tk};
  864.     if ($expr =~ /DO_ARRAY_ELEM/) {
  865.         blurt("Error: '$subtype' not in typemap"), return 
  866.         unless defined($type_kind{$subtype});
  867.         blurt("Error: No INPUT definition for type '$subtype' found"), return
  868.             unless defined $input_expr{$type_kind{$subtype}} ;
  869.     $subexpr = $input_expr{$type_kind{$subtype}};
  870.     $subexpr =~ s/ntype/subtype/g;
  871.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  872.     $subexpr =~ s/\n\t/\n\t\t/g;
  873.     $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
  874.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  875.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  876.     }
  877.     if (defined($defaults{$var})) {
  878.         $expr =~ s/(\t+)/$1    /g;
  879.         $expr =~ s/        /\t/g;
  880.         eval qq/print "\\t$var;\\n"/;
  881.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  882.     } elsif ($expr !~ /^\t\$var =/) {
  883.         eval qq/print "\\t$var;\\n"/;
  884.         $deferred .= eval qq/"\\n$expr;\\n"/;
  885.     } else {
  886.         eval qq/print "$expr;\\n"/;
  887.     }
  888. }
  889.  
  890. sub generate_output {
  891.     local($type, $num, $var) = @_;
  892.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  893.     local($argoff) = $num - 1;
  894.     local($ntype);
  895.  
  896.     $type = TidyType($type) ;
  897.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  898.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  899.     } else {
  900.         blurt("Error: '$type' not in typemap"), return
  901.         unless defined($type_kind{$type});
  902.             blurt("Error: No OUTPUT definition for type '$type' found"), return
  903.                 unless defined $output_expr{$type_kind{$type}} ;
  904.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  905.         $ntype =~ s/\(\)//g;
  906.         $subtype = $ntype;
  907.         $subtype =~ s/Ptr$//;
  908.         $subtype =~ s/Array$//;
  909.         $expr = $output_expr{$type_kind{$type}};
  910.         if ($expr =~ /DO_ARRAY_ELEM/) {
  911.             blurt("Error: '$subtype' not in typemap"), return
  912.             unless defined($type_kind{$subtype});
  913.                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
  914.                     unless defined $output_expr{$type_kind{$subtype}} ;
  915.         $subexpr = $output_expr{$type_kind{$subtype}};
  916.         $subexpr =~ s/ntype/subtype/g;
  917.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  918.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  919.         $subexpr =~ s/\n\t/\n\t\t/g;
  920.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  921.         eval "print qq\a$expr\a";
  922.         }
  923.         elsif ($var eq 'RETVAL') {
  924.         if ($expr =~ /^\t\$arg = /) {
  925.             eval "print qq\a$expr\a";
  926.             print "\tsv_2mortal(ST(0));\n";
  927.         }
  928.         else {
  929.             print "\tST(0) = sv_newmortal();\n";
  930.             eval "print qq\a$expr\a";
  931.         }
  932.         }
  933.         elsif ($arg =~ /^ST\(\d+\)$/) {
  934.         eval "print qq\a$expr\a";
  935.         }
  936.     }
  937. }
  938.  
  939. sub map_type {
  940.     my($type) = @_;
  941.  
  942.     $type =~ s/:/_/g;
  943.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  944.         return "$1 *";
  945.     } else {
  946.         return $type;
  947.     }
  948. }
  949.  
  950.  
  951. sub Exit {
  952. # If this is VMS, the exit status has meaning to the shell, so we
  953. # use a predictable value (SS$_Abort) rather than an arbitrary
  954. # number.
  955.     exit ($Is_VMS ? 44 : $errors) ;
  956. }
  957.